Power Programmierung/Power-Programmierung (Tewi)(1994).iso/magazine/progjour/1988/06/fcode/mazil2.for

Text File | 1987-09-03 | 12KB | 168 lines

C*  SUBROUTINE MAZIL2
C*
C*       \PE HA\HA\EHA  \\ B\BO A -PA \KOB TA\\\\HO OR AHH\X
C*        \HK \\ ( C PABH\M \A-OM ) HA A \\
C*
C*   OPMA\\H\E \APAMETP\:
C*
C*  L1   FIELD     - \T\M\ C\MBO\AM\ \\ ET \A\O\HEHO BCE \O\E -PA \KA
C*                   O\\\HO B KA\ECTBE FIELD \A AETC\ \PO\E\
C*  L1   EQSMBL    - \T\M\ C\MBO\AM\ \O \MO\\AH\8 \E\ATA8TC\ BCE
C*                   -PA \K\, \O \E\A\\E B\BO \
C*  L    LEQ       - OTMEHA \MO\\AH\\ HA B\\OP C\MBO\OB, \C\O\\\\EM\X
C*                    \\ \E\AT\ -PA \KOB. \P\ LEQ = .FALSE.
C*                   COOTBETCTB\8\\E C\MBO\\ \\ \T HA\ EH\ B MACC\BE
C*                   SMBLS (CM.H\\E)
C*  INT  NFUN      - KO\\\ECBO  \HK \\, \O \E\A\\X B\BO \
C*
C*  INT  N         - \\C\O TO\EK -PA \KA, OTHOC\\\XC\ K O HO\
C*                    \HK \\ ( PABHO  \\ BCEX NFUN  \HK \\ )
C*  R    FUN       - TA\\\ A \HA\EH\\  \HK \\, \O \E\A\\X B\BO \
C*                   ( MATP\ A, CO EP\A\A\ NFUN CTO\\ OB \ N CTPOK )
C*  L1   SMBLS     - MACC\B, CO EP\A\\\ TA\\\ \ C\MBO\OB  \\  \E\AT\
C*                   -PA \KOB ( \P\ LEQ = .FALSE. ), \P\\EM BCE
C*                   C\MBO\\ MO-\T \\T\ PA\\\\H\M\
C*  R8   LBX       - HA\A\HOE \HA\EH\E \EPEMEHHO\ X
C*
C*  R8   STX       - \A- B O\\  X
C*
C*  R8   LBY       - H\\H\\    -PAH\ A B\BO \M\X \HA\EH\\ Y
C*
C*  R8   SCY       - \KA\A Y
C*
C*  INT  GR        - \E\AT\ CETK\ HA -PA \KE ( 0-HE \E\., 1-\O X,
C*                   2-\O Y, 3-\O X \ \O Y
C*  INT  DIGY      - \E\AT\ O \ POBK\ OC\ Y  ( 0-HE \E\., 1-TO\\KO
C*                   BHA\A\E, 2-TO\\KO B KOH E, 3-BHA\A\E \ B KOH E )
C*  INT  GRINTX    - \HTEPBA\ CETK\ \O X ( \EPE\ GRINTX TO\EK X
C*                   \POBO \T\ \\H\8 CETK\ ).
C*  INT  FSTNX     - HA\A\\HOE \HA\EH\E HOMEPA AP-\MEHTA X ( HOMEPA
C*                   TO\EK \E\ATA8TC\ HAP\ \ CO \HA\EH\\M\ X ).
C*  L    LALLX     - \E\ATAT\ BCE \HA\EH\\ AP-\MEHTA X ( LALLX=.TRUE.)
C*                   \\\ TO\\KO 'CETO\H\E' ( LALLX=.FALSE.)
C*
C*  INT  NEMP      - \\C\O \\CT\X CTPOK, BCTAB\\EM\X ME\ \ COCE H\M\
C*                   CTPOKAM\, CO EP\A\\M\ TO\K\ -PA \KA
C*
C*       V.V.KHOTKEVICH, A.V.KHOTKEVICH (PTILT AS UKRSSR)
C*            ISSUED      06.06.85
C*
C*
      SUBROUTINE MAZIL2 (FIELD,EQSMBL,LEQ,NFUN,N,FUN,SMBLS,LBX,STX,
     &                   LBY,SCY,GR,DIGY,GRINTX,FSTNX,LALLX,NEMP)
C
      INTEGER    NFUN,N,GR,DIGY,GRINTX,FSTNX,NEMP
      LOGICAL*1  FIELD,EQSMBL,SMBLS(NFUN)
      LOGICAL    LEQ,LALLX
      REAL       FUN(N,NFUN)
      REAL*8     LBX,STX,LBY,SCY
C
      INTEGER    GRX,GRY,GRXY,DIGYF,DIGYL,DIGYFL
      INTEGER    NUM,NX,NJ,ARG,NN,J,I,II,POS,FCONTR,ALL,K
      LOGICAL*1  PALKA,HYPHEN,PLUS,S(101)
      LOGICAL    GX,GY
      REAL*8     RESY,X,E,GREEDY(11)
      REAL*8     DBLE
C
   11 FORMAT(18X,11(1X,G9.3))
   22 FORMAT(19X,101A1)
   33 FORMAT(9X,G9.3,1X,101A1)
   44 FORMAT(2X,I5,12X,101A1)
   55 FORMAT(2X,I5,2X,G9.3,1X,101A1)
C
      DATA       PALKA/1H|/, HYPHEN/1H-/, PLUS/1H+/
      DATA       GRX/1/, GRY/2/, GRXY/3/, DIGYF/1/, DIGYL/2/, DIGYFL/3/
C
      GX = .FALSE.
      GY = .FALSE.
      IF (GR .EQ. GRX .OR. GR .EQ. GRXY) GX = .TRUE.
      IF (GR .EQ. GRY .OR. GR .EQ. GRXY) GY = .TRUE.
      NUM = 0
      NX = FSTNX
      IF (NX .GT. 0) NUM = 2
      IF (NX .LE. 0) NX = 1
      ALL = 0
      IF (LALLX) ALL = 1
      RESY = (SCY-LBY) * 1.D-2
      DO 10 I = 1, 11
       GREEDY(I) = LBY +   DBLE(I-1) * (SCY-LBY) * 1.D-1
   10 CONTINUE
      IF (DIGY .EQ. DIGYF .OR. DIGY .EQ. DIGYFL) WRITE(5,11) GREEDY
      NJ = 1
      DO 200 J = 1, N
        ARG = 1
        DO 20 I = 2, 100
          S(I) = FIELD
   20   CONTINUE
        S(1)   = PALKA
        S(101) = PALKA
        X = LBX +   DBLE(J-1) * STX
        NN = J - 1 + NX
        IF (.NOT. GY) GO TO 40
          DO 30 I = 2, 10
            II = (I-1) * 10 + 1
            S(II) = PALKA
   30     CONTINUE
   40   CONTINUE
        IF (J .EQ. 1 .OR. J .EQ. N) GO TO 42
          IF (J .NE. (NJ-1)*GRINTX+1) GO TO 70
   42   CONTINUE
          IF (.NOT. LALLX) ARG = 2
          NJ = NJ + 1
          IF (J .EQ. 1 .OR. J .EQ. N) GO TO 45
            IF (.NOT. GX) GO TO 70
   45     CONTINUE
          DO 50 I = 2, 100
            S(I) = HYPHEN
   50     CONTINUE
          DO 60 I = 1, 11
            II = (I-1) * 10 + 1
            S(II) = PLUS
   60     CONTINUE
   70   CONTINUE
        DO 90 I = 1, NFUN
          E = (FUN(J,I) - LBY) / RESY + 1.D0
          POS = E
          II = E + 0.5D0
          IF (II .GT. POS) POS = POS + 1
          IF (POS .LT. 1 .OR. POS .GT. 101) GO TO 80
            S(POS) = SMBLS(I)
            IF (LEQ) S(POS) = EQSMBL
   80     CONTINUE
   90   CONTINUE
        FCONTR = ARG + ALL + NUM
        GO TO (100,110,120,130), FCONTR
  100   CONTINUE
          WRITE(5,22) S
          GO TO 140
  110   CONTINUE
          WRITE(5,33) X,S
          GO TO 140
  120   CONTINUE
          WRITE(5,44) NN,S
          GO TO 140
  130   CONTINUE
          WRITE(5,55) NN,X,S
  140   CONTINUE
        IF (NEMP .LE. 0) GO TO 190
        IF (J .EQ. N) GO TO 190
          DO 180 I = 1, NEMP
            DO 150 II = 2, 100
              S(II) = FIELD
  150       CONTINUE
            IF (.NOT. GY) GO TO 170
              DO 160 II = 2, 10
                K = (II-1) * 10 + 1
                S(K) = PALKA
  160         CONTINUE
  170       CONTINUE
            S(1)   = PALKA
            S(101) = PALKA
            WRITE(5,22) S
  180     CONTINUE
  190   CONTINUE
  200 CONTINUE
      IF (DIGY .EQ. DIGYL .OR. DIGY .EQ. DIGYFL) WRITE(5,11) GREEDY
      RETURN
      END